home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue64 / Alfresco / TstRndWt.dpr < prev    next >
Encoding:
Text File  |  2000-10-23  |  2.8 KB  |  103 lines
  1. {*********************************************************}
  2. {* TstRndWt                                              *}
  3. {* Copyright (c) Julian M Bucknall 2000                  *}
  4. {* All rights reserved.                                  *}
  5. {*********************************************************}
  6. {* Algorithms Alfresco: Weighted random numbers          *}
  7. {*********************************************************}
  8.  
  9. {Note: this unit is released as freeware. In other words, you are free
  10.        to use this unit in your own applications, however I retain all
  11.        copyright to the code. JMB}
  12.  
  13. program TstRndWt;
  14.  
  15. {$APPTYPE CONSOLE}
  16.  
  17. uses
  18.   SysUtils;
  19.  
  20. const
  21.   Epsilon = 1E-10;
  22.  
  23. {===TaaRandomWeightedGenerator=======================================}
  24. type
  25.   TaaRandomWeightedGenerator = class
  26.     private
  27.       FCount   : integer; 
  28.       FWeights : array of double;
  29.     protected
  30.     public
  31.       constructor Create(const aWeights : array of double);
  32.       destructor Destroy; override;
  33.  
  34.       function Get : integer;
  35.   end;
  36. {--------}
  37. constructor TaaRandomWeightedGenerator.Create(const aWeights : array of double);
  38. var
  39.   i : integer;
  40.   TotalWeight : double;
  41. begin
  42.   inherited Create;
  43.   Assert(length(aWeights) <> 0,
  44.          'An array of weights must be provided');
  45.  
  46.   SetLength(FWeights, length(aWeights));
  47.   TotalWeight := 0.0;
  48.   FCount := succ(High(aWeights));
  49.   for i := 0 to pred(FCount) do begin
  50.     TotalWeight := TotalWeight + aWeights[i];
  51.     FWeights[i] := TotalWeight;
  52.   end;
  53.   if (abs(TotalWeight - 1.0) > Epsilon) then
  54.     raise Exception.Create('The weights to not total 1.0');
  55.   FWeights[pred(FCount)] := 1.0;
  56. end;
  57. {--------}
  58. destructor TaaRandomWeightedGenerator.Destroy;
  59. begin
  60.   SetLength(FWeights, 0);
  61.   inherited Destroy;
  62. end;
  63. {--------}
  64. function TaaRandomWeightedGenerator.Get : integer;
  65. var
  66.   Value : double;
  67.   i     : integer;
  68. begin
  69.   Value := Random;
  70.   for i := 0 to pred(FCount) do begin
  71.     if (Value < FWeights[i]) then begin
  72.       Result := succ(i);
  73.       Exit;
  74.     end;
  75.   end;
  76.   {we shouldn't ever get here: this staement is merely to fool the
  77.    compiler into not giving us a warning about the result value}
  78.   Result := FCount;
  79. end;
  80. {====================================================================}
  81.  
  82.  
  83. const
  84.   MaxCount = 1000000;
  85. var
  86.   RandGen : TaaRandomWeightedGenerator;
  87.   Buckets : array [1..6] of integer;
  88.   i       : integer;
  89. begin
  90.   RandGen := TaaRandomWeightedGenerator.Create([0.1, 0.2, 0.3, 0.2, 0.1, 0.1]);
  91.   try
  92.     FillChar(Buckets, sizeof(Buckets), 0);
  93.     for i := 1 to MaxCount do
  94.       inc(Buckets[RandGen.Get]);
  95.     writeln('Bucket counts and ratios...');
  96.     for i := 1 to 6 do
  97.       writeln(Buckets[i]:6, '    ', Buckets[i]/MaxCount:7:4);
  98.   finally
  99.     RandGen.Free;
  100.   end;
  101.   readln;
  102. end.
  103.